home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / tfix5.t < prev    next >
Text File  |  1993-07-09  |  4KB  |  115 lines
  1. (herald tfix5 (env tsys)
  2.               (syntax-table (env-syntax-table t-implementation-env)))
  3.  
  4. (load-if-present '(tsystem ofix5) orbit-env)
  5.  
  6. ;; scheme eof fix, throw fix, iob-writable? fix
  7.  
  8.  
  9. (*define (*value standard-env 'scheme-env) 'eof eof)
  10. (*define (*value standard-env 'scheme-env) 'true true)
  11. (*define (*value standard-env 'scheme-env) 'cond-=>-aux cond-=>-aux)
  12. (*define (*value standard-env 'scheme-env) 'equal? equal?)
  13.  
  14. (define (continuation-throw sp stack vals k-state base-state)
  15.   (cond ((stack? stack)
  16.          (let ((a (swap *the-current-throw-value* vals))
  17.                (b (swap *the-current-throw-frame* stack)))
  18.            (unwind-to-top)
  19.            (set *the-current-throw-frame* b)
  20.            (set *the-current-throw-value* a)
  21.            (set (process-global task/dynamic-state) k-state)
  22.            (invoke-continuation sp stack vals base-state k-state)))
  23.         (else
  24.          (error "throwing ~s to bad continuation ~s" vals stack))))
  25.                                   
  26.                              
  27. (define (unwind-to-top)
  28.   (iterate loop ((state (process-global task/dynamic-state)))
  29.     (cond ((eq? state nil))
  30.           ((eq? (state-winder state) false)
  31.        (loop (state-previous state)))
  32.           (else
  33.            (perform-unwind state)
  34.            (loop (state-previous state))))))
  35.  
  36. (define-integrable (iob-writable? iob)
  37.   (or (iob-mode? (iob-mode iob) iob/write)
  38.       (iob-mode? (iob-mode iob) iob/append)))
  39.  
  40. (define (init-buffer buf mode underflow overflow)
  41.   (set (iob-mode        buf) mode)
  42.   (set (iob-offset      buf) 0)
  43.   (set (iob-h           buf) 0)
  44.   (set (iob-prev-h      buf) 0)
  45.   (set (iob-v           buf) 0)
  46.   (set (iob-indent      buf) 0)
  47.   (set (iob-wrap-column buf) standard-wrap-column)
  48.   (set (iob-line-length buf) standard-line-length)
  49.   (set (iob-rt          buf) '#f)
  50.   (set (iob-eof-flag?   buf) '#f)
  51.   (cond ((iob-readable? buf)
  52.          (set (iob-limit     buf) 0)
  53.          (set (iob-underflow buf) underflow)
  54.          (set (iob-overflow  buf) overflow-error))
  55.         ((iob-writable? buf)
  56.          (set (iob-limit     buf) (max-buffer-length buf))
  57.          (set (iob-underflow buf) underflow-error)
  58.          (set (iob-overflow  buf) overflow)))
  59.   buf)
  60.  
  61. (define (CLOSE-PORT iob)
  62.   (let ((iob (enforce iob? iob)))
  63.     (cond ((iob-permanent? iob)
  64.            (nc-error "attempt to close a permanent port - ~a" iob))
  65.           ((iob-closed? iob)
  66.            (no-value))
  67.           (else
  68.            (if (iob-writable? iob) (%vm-write-buffer iob))
  69.            (if (iob-channel iob) (%vm-close-file iob))
  70.         ;++(set (table-entry open-port-table iob) nil)
  71.            (release-buffer-text %buffer-pool iob)
  72.            (set (iob-buffer iob) '#f)
  73.            (set (iob-mode   iob) iob/closed)
  74.            (set (iob-xeno   iob) '#f)
  75.            ;; make it fail in VM-READ-CHAR
  76.            (set (iob-limit  iob) -1)
  77.            (no-value)))))
  78.  
  79. (define (make-default-herald filename)
  80.   (let ((h (make-herald)))
  81.     (set (herald-filename  h) (->filename filename))
  82.     h))
  83.  
  84. (define (read-inline-comment port ch n rt)
  85.   (ignore ch n rt)
  86.   (let ((readc (if (iob? port) vm-read-char read-char)))
  87.     (labels (((error)
  88.               (read-error port "end of file within #|...|# (missing delimiter)"))
  89.              ((loop level)
  90.               (let ((ch (readc port)))
  91.                 (cond ((eof? ch) (error))
  92.                       ((char= ch #\|)
  93.                        (let ((ch (readc port)))
  94.                          (cond ((eof? ch) (error))
  95.                                ((charn= ch #\#)
  96.                                 (unread-char port)
  97.                                 (loop level))
  98.                                ((fx= level 1)
  99.                                 nothing-read)
  100.                                (else
  101.                                 (loop (fx- level 1))))))
  102.                       ((char= ch #\#)
  103.                        (let ((ch (readc port)))
  104.                          (cond ((eof? ch) (error))
  105.                                ((char= ch #\|)
  106.                                 (loop (fx+ level 1)))
  107.                                (else
  108.                                 (unread-char port)
  109.                                 (loop level)))))
  110.                       (else (loop level))))))
  111.       (loop 1))))
  112.  
  113. (set-dispatch-syntax read-dispatch #\| read-inline-comment)
  114.  
  115.